home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr51
/
lib201.zip
/
OBSOLETE.PRG
< prev
next >
Wrap
Text File
|
1993-04-27
|
26KB
|
634 lines
*-------------------------------------------------------------------------------
*-- Program...: OBSOLETE.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- Notes.....: The following functions are not necessary using dBASE IV, 1.5,
*-- but have been retained in the current version of the library
*-- system in order to have some compatibility with 1.1.
*-------------------------------------------------------------------------------
FUNCTION Empty
*-------------------------------------------------------------------------------
*-- Programmer..: Jerry Wightman (WIGHTMAN)
*-- Date........: ?
*-- Notes.......: Used to check whether a memory variable in dBASE contains
*-- anything, based on type of field. (Pulled from BORBBS)
*-- NOTE: In release 1.5, replace all calls to EMPTY() with
*-- the new: ISBLANK() function. This will be faster.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Empty(<cFld>)
*-- Example.....: @5,10 say "Enter date: " get bDate;
*-- valid required .not. empty(bDate);
*-- error chr(7)+"** Date cannot be Empty! **"
*-- Returns.....: Logical (.t./.f.)
*-- Parameters..: cFld = Field/Memvar/Expression to check for "Emptiness"
*-------------------------------------------------------------------------------
PARAMETERS cFld && may be memory variable or database field name
private cTalk, lReturn
cTalk = SET("TALK")
lReturn = .F. && FALSE means: variable is NOT empty
do case
case type( "cFld" ) = "C"
if len( ltrim(rtrim( cFld )) ) = 0
lReturn = .T.
endif
case type( "cFld" ) = "N" .or. type( "cFld" ) = "F"
if cFld = 0
lReturn = .T.
endif
case type( "cFld" ) = "L"
lReturn = .F. && Can't check logical fields
case type( "cFld" ) = "D"
if cFld = {}
lReturn = .T.
endif
case type( "cFld" ) = "M"
if len( cFld ) = 0
lReturn = .T.
endif
otherwise && TYPE = "U"
lReturn = .T.
endcase
set talk &cTalk
RETURN lReturn
*-- EoF: Empty()
FUNCTION NumFlds
*-------------------------------------------------------------------------------
*-- Programmer..: Bowen Moursund (CIS: 76566,1405)
*-- Date........: 07/12/1991
*-- Notes.......: Returns the number of fields in a database structure --
*-- only in the currently selected DBF
*-- NOTE: In release 1.5, replace function NUMFLDS() with
*-- FLDCOUNT() -- built in to 1.5, faster ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/12/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NumFlds()
*-- Example.....: ? NumFlds()
*-- Returns.....: Number of fields
*-- Parameters..: None
*-------------------------------------------------------------------------------
private nFlds,cFldName
*-- If currently selected database is empty (no dbf file)
if len(trim(dbf())) = 0
nFlds = 0 && set to 0
*-- we have something ...
else
nFlds = 0 && initialize
do while .t. && loop through the record structure
nFlds= nFlds + 1 && increment counter
cFldName = field(nFlds) && get fieldname
if len(trim(cFldName)) = 0 && if length = 0,
nFlds = nFlds - 1 && decrement counter
exit && get out of loop, we're done
endif && endif(length...)
enddo && end of loop
endif
RETURN nFlds
*-- EoF: NumFlds()
FUNCTION DateSet
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns string giving name of current DATE format
*-- This is not needed in Version 1.5, in which set("DATE")
*-- returns the format. Unlike that function in 1.5, this
*-- one cannot distinguish between date formats set with
*-- different terms that amount to the same thing:
*-- DMY = BRITISH = FRENCH
*-- MDY = AMERICAN
*-- YMD = JAPAN
*-- If your users will be using one of these formats and
*-- are sensitive about the name, substitute the one they
*-- want for the equivalent in this function.
*-- Rev. History: 03/01/1992 -- Original
*-- Written for.: dBASE IV, versions below 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateSet()
*-- Example.....: ?DateSet()
*-- Returns.....: Character
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cCent, cTestdate, cDelimiter
cCent = set( "CENTURY" )
set century off
cTestdate = ctod( "01/02/03" )
cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
set century &cCent
do case
case month( cTestdate ) = 1
RETURN iif( cDelimiter = "-", "USA", "MDY" )
case day( cTestdate ) = 1
RETURN iif( cDelimiter = "/", "DMY", ;
iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
otherwise
RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
endcase
*-- EoF: DateSet()
FUNCTION Stampval
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/07/1992
*-- Notes.......: Passed a 16-character string in the form of the rightmost
*-- : 16 characters returned by the DOS DIR command for a file,
*-- : returns a number that will compare properly in date/time
*-- : order with the numbers returned by this function for other
*-- : files.
*-- Written for.: dBASE IV Versions below 1.5
*-- Rev. History: 04/07/1992
*-- Calls : None
*-- Called by...: Any
*-- Usage.......: Stampval(<cTimestamp>)
*-- Example.....: IF Stampval("02-22-92 10:54a") > Stampval("04-05-92 5:54p")
*-- Returns.....: Numeric corresponding to time stamp of file
*-- Parameters..: cStamp, a DIR timestamp
*-------------------------------------------------------------------------------
parameters cStamp
RETURN 1440 * ( 12 * val( left(cStamp,2)) + val(substr(cStamp,4,2)) ;
+ 372*val(substr(cStamp,7,2)) ) + 60 * val(substr(cStamp,11,2)) ;
+ val(substr(Cstamp,14,2)) + iif(right(cStamp,1)="p",720,0)
*--Eof() Stampval
PROCEDURE FullWin
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/91
*-- Notes.......: Overlays menus or another screen with a full window,
*-- so that processing is done in the window, and one can return
*-- directly to the menus, without redrawing screen and such.
*-- This routine may be a problem in dBASE IV, 1.5 ... use
*-- with caution ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
*-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
*-- * perform whatever actions are needed in the window
*-- deactivate window wEdit
*-- release window wEdit
*-- restore screen from sMain
*-- release screen sMain
*-- Returns.....: None
*-- Parameters..: cColor = Colors for window
*-- cWinName = Name of window
*-- cScreen = Name of screen
*-------------------------------------------------------------------------------
parameters cColor,cWinName,sScreen
define window &cWinName from 0,0 to 23,79 none color &cColor.
save screen to &sScreen.
activate window &cWinName.
RETURN
*-- EoP: FullWin
PROCEDURE SetColor
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*-- checks to see if a color monitor is attached (ISCOLOR()),
*-- and sets system variables, that can be used in SET COLOR OF
*-- commands. You must define the memvars as PUBLIC, see Example
*-- below -- otherwise nothing will work.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*-- program) and commented a bit more, minor modifications by
*-- Ken Mayer
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor
*-- Example.....: in a menu or setup program:
*-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*-- cl_entry,cl_stand,cl_menu,cl_warn
*-- DO setcolor
*-- by declaring the variables PUBLIC before calling SETCOLOR
*-- they should be globally available throughout, unless you
*-- use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
if file("COLOR.MEM")
restore from Color.mem additive && if color.mem exists, restore from it
else && otherwise, create it
lC = iscolor() && remember -- foreground/background
cl_Blank = "n/n,n/n,n" && black on black on black ...
cl_Func = "n/w" && function keys (used in CLRSHOW)
* if iscolor() = true, define color, otherwise black/white
cl_Help = iif(lC,"n/g,g/n,n" , "w+/n,n/w,n") && help
cl_Data = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") && data entry fields
cl_Error = iif(lC,"rg+/r,w/n,n" , "w+/n,n/w,n") && error messages
cl_Entry = iif(lC,"n/w,w/n,n" , "n/w,w/n,n") && data entry??
cl_Stand = iif(lC,"w+/b,b/w,n" , "w+/n,n/w,n") && standard screen
cl_Menu = iif(lC,"rg+/b,b/w,n" , "w+/n,n/w,n") && menus
cl_Warn = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && warning messages
save to color all like cl_* && create COLOR.MEM
endif
*-- change current color settings to these ...
set color to &cl_stand
cTemp = extrclr("&cl_data")
set color of fields to &cTemp
set color of messages to &cTemp
set color of box to &cTemp
cTemp = extrclr("&cl_stand")
set color of highlight to &cTemp
RETURN
*-- EoP: SetColor
PROCEDURE SetColor2
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*-- checks a parameter passed by the programmer to see if the
*-- monitor is a color system. It then creates the proper color
*-- combinations based on this ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*-- program) and commented a bit more, minor modifications by
*-- Ken Mayer 11/21/91 -- Modified for parameter ...
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor2 with "<cYN>"
*-- Example.....: in a menu or setup program:
*-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*-- cl_entry,cl_stand,cl_menu,cl_warn
*-- DO setcolor2 with "Y"
*-- by declaring the variables PUBLIC before calling SETCOLOR
*-- they should be globally available throughout, unless you
*-- use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: cYN = "Y" for color, "N" for mono ...
*-------------------------------------------------------------------------------
parameter cYN
private lC, cTemp
lC = iif(cYN="Y",.t.,.f.) && remember -- foreground/background
cl_Blank = "n/n,n/n,n" && black on black on black ...
cl_Func = "n/w" && function keys
cl_Help = iif(lC,"n/g,g/n,n" , "w+/n,n/w,n") && help
cl_Data = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n") && data entry fields
cl_Error = iif(lC,"rg+/r,w/n,n" , "w+/n,n/w,n") && error messages
cl_Entry = iif(lC,"n/w,w/n,n" , "n/w,w/n,n") && data entry??
cl_Stand = iif(lC,"w+/b,b/w,n" , "w+/n,n/w,n") && standard screen
cl_Menu = iif(lC,"rg+/b,b/w,n" , "w+/n,n/w,n") && menus
cl_Warn = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && warning messages
save to color all like cl_* && create COLOR.MEM
*-- change current color settings to these ...
set color to &cl_stand
cTemp = extrclr("&cl_data")
set color of fields to &cTemp
set color of messages to &cTemp
set color of box to &cTemp
cTemp = extrclr("&cl_stand")
set color of highlight to &cTemp
RETURN
*-- EoP: SetColor2
FUNCTION ExtrClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/24/1991
*-- Notes.......: Used to extract the first parameter of the MEMVARS
*-- created from SETCOLOR above. The SET COLOR OF commands can
*-- only use the first parameter.
*-- It is recommended that you run SetColor (above) first,
*-- although if you define your own color memvars, this will work
*-- just as well.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/24/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: extrclr(<cMemVar>)
*-- Example.....: set color of highlight to &extrclr(cl_stand)
*-- Returns.....: "W+/B"
*-- Parameters..: cMemVar = color memory variable to have colors extracted from
*-------------------------------------------------------------------------------
parameters cMemVar
RETURN substr(cMemVar,1,(at(",",cMemVar)-1))
*-- EoF: ExtrClr()
FUNCTION InvClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/1991
*-- Notes.......: Used to set an inverse color, using value(s) returned
*-- from extrclr above, or from a single color memvar.
*-- Inverted colors may give odd results -- RG+ (yellow) is
*-- not a background color, for example, and will appear as
*-- RG (brown) -- this may not be what you wanted ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: invclr(<cMemVar>)
*-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
*-- or
*-- x = extrclr(cl_stand)
*-- set color of highlight to &invclr(x)
*-- Returns.....: "B/W+"
*-- Parameters..: cMemVar = color variable containing colors to be inverted
*-------------------------------------------------------------------------------
parameters cMemVar
private cTemp1, cTemp2
cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))
RETURN cTemp2+"/"+cTemp1
*-- EoF: InvClr()
**********************************************************************
***** THE FOLLOWING WERE MOVED HERE FROM OTHER LIBRARY FILES FOLLOWING
***** THE RELEASE OF dBASE IV, 2.0. KJM
**********************************************************************
FUNCTION Rat
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Reverse "at", returns position a character string is last
*-- AT in a larger string.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Rat("<cFindStr>","<cBigStr>")
*-- Example.....: ? Rat("Test","This is a Test string, with Test data")
*-- Returns.....: Numeric value
*-- Parameters..: cFindStr = string to find in cBigStr
*-- cBigStr = string to look in
*-------------------------------------------------------------------------------
parameters cFindstr, cBigstr
private nPos,nLen
nLen = len( cFindstr )
nPos = len( cBigstr ) - nLen + 1
do while nPos > 0
if substr( cBigstr, nPos, nLen ) = cFindstr
exit
else
nPos = nPos - 1
endif
enddo
RETURN max( nPos, 0 )
*-- EoF: RAt()
FUNCTION IsMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 06/18/1992
*-- Notes.......: This is used to determine the presence of a mouse driver.
*-- Returns a .t. if a mouse driver is detected, a .f. otherwise.
*-- This routine will turn the mouse off, automatically. This
*-- can be used to detect a mouse, and turn it off, as well
*-- as to set a memvar to determine the current mouse state.
*-- For example, after running this routine, the mouse will be
*-- off (if there's a driver).
*-- ******************************
*-- **** REQUIRES JPMOUSE.BIN ****
*-- ******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/18/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsMouse()
*-- Example.....: ?IsMouse()
*-- Returns.....: Logical
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cRetVal, lIsMouse, X
Load JPMOUSE.BIN
cRetVal = call("JPMOUSE","?")
lIsMouse = iif(cRetVal="T",.t.,.f.)
if lIsMouse
x = call("JPMOUSE","H")
endif
release module JPMOUSE
RETURN lIsMouse
*-- EoF: IsMouse()
PROCEDURE SetMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 06/18/1992
*-- Notes.......: This is used to determine the presence of a mouse driver,
*-- and/or turn the mouse cursor off in dBASE IV, 1.5
*-- ******************************
*-- **** Requires JPMOUSE.BIN ****
*-- ******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/18/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do SetMouse with <c_Mouse>
*-- Example.....: PUBLIC c_Mouse
*-- x=ismouse() && function in MISC.PRG
*-- store "OFF" to c_Mouse && after calling IsMouse() it's 'Off'
*-- ON KEY LABEL Alt-M DO SetMouse
*-- Returns.....: .T.
*-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
*-- by this procedure to the opposite scenario when the
*-- routine is called. The concept here is to switch
*-- the mouse on and/or off if there's a mouse driver.
*-- This memvar should be set to the current status of the mouse-
*-- if on, it should hold "ON" in it ...
*-------------------------------------------------------------------------------
private X
if type("C_MOUSE") # "C" && if c_Mouse has not been defined as
return && a character field, return
endif
load JPMOUSE.BIN && load the module
*-- if the mouse is off, we're going to set it on ("S"), if on, we're
*-- going to set it off "H")
cSetMouse = iif(upper(c_Mouse) = "OFF","S","H")
x=call("JPMOUSE",cSetMouse)
release module JPMOUSE && remove from memory
*-- if c_Mouse was 'off' we are setting it 'on', and vice versa
c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse
RETURN
*-- EoP: SetMouse
FUNCTION IsUnique
*********************************************************************
** ** WARNING WARNING WARNING **
** Extensive testing has shown that this routine causes problems in
** dBASE IV, 1.5 and later. Use SEEK() or SEEK instead, to determine
** uniqueness (if FOUND() and all that ...)
**********************************************************************
*-------------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES)
*-- Date........: 04/28/1992
*-- Notes.......: Checks to see if an index key already exists in the current
*-- selected database. This function was inspired by Tom
*-- Woodward's Chk4Dup UDF.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: May 15, 1991 Version 1.1 Added check for zero record database
*-- May 7, 1991 Version 1.0 Initial 'release'.
*-- 04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
*-- behavior (see READ.ME that comes with 1.5). Should function
*-- fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
*-- NOTE: NEW PARAMETER
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
*-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
*-- valid required IsUnique(SSN, "SSN", "SSN");
*-- message "Enter a new SSN";
*-- error chr(7)+"SSN must be unique!"
*-- Returns.....: .T./.F.
*-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
*-- cOrder = MDX Tag used to order the database. Must be set for
*-- field being checked.
*-- cField = field name for 'get'.
*-------------------------------------------------------------------------------
parameters xValue, cOrder, cField
private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
private lIsUnique
nRecNo = recno() && store current record number
nRecCnt = reccount() && count records in database
if nRecCnt = 0 && empty database, cValue MUST be unique
return .t.
endif
cSetNear = set('NEAR') && store status of NEAR flag
set near off && set it off
cSetDel = set('DELETE') && store status of DELETE
set delete on && Delete must be ON for this to work
lIsDeleted = deleted() && is current record deleted?
delete && set delete flag for current record
cSetOrder = order() && store current MDX tag
set order to (cOrder) && set tag to that sent to function
if seek(xValue) && does it exist already?
lIsUnique = .f. && if so, it's not unique
else && otherwise,
lIsUnique = .t. && it is.
endif
set order to (cSetOrder) && restore changed settings to original settings
set delete &cSetDel
set near &cSetNear
if nRecNo > nRecCnt && if called during an append
go bottom && goto the bottom of the database,
skip 1 && plus one record (the new one)
if lIsUnique && this is the new part ...
replace &cField with xValue
endif
else
go nRecNo && otherwise, goto the current record number
endif
if .not. lIsDeleted && was record 'deleted' before?
recall && if not, undelete it ... (turn flag off)
endif
RETURN (lIsUnique)
*-- EoF: IsUnique()
FUNCTION Delay
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Delay Loop. Returns .T. after lapse of given number of
*-- seconds. Accurate to one second. For dBASE IV 2.0, use
*-- the upgraded version in Time.prg.
*-- This may be used in conjunction with EXACTIME.BIN or a
*-- similar routine that obtains the tick count. In that case,
*-- the delay may be made accurate to one tick. To use it this
*-- way, add:
*-- LOAD Exactime
*-- Arg = space(11)
*-- and substitute for each call of the time() function:
*-- call( "Exactime", Arg )
*--
*-- Written for.: dBASE IV, Versions below 2.0
*-- Rev. History: 03/01/1992 -- Original function
*-- 04/20/1993 -- modified to deal with fractions, bug fixed
*-- Calls.......: TIME2SEC() Function in TIME.PRG
*-- Called by...: Any
*-- Usage.......: Delay(<nSeconds>)
*-- Example.....: lX= Delay(10.25)
*-- Returns.....: Logical
*-- Parameters..: nSeconds = number of seconds to delay
*-------------------------------------------------------------------------------
parameters nSeconds && up to 86400, one day
private nTimeout, nTimenow, lRollover
nTimeout = 100 * ( Time2Sec( time() ) + nSeconds )
if nTimeout > 8640000
lRollover = .T.
nTimeout = nTimeout - 8640000
else
lRollover = .F.
endif
do while .T.
nTimenow = 100 * Time2Sec( time() )
if nTimenow < nTimeout
lRollover = .F.
else
if .not. lRollover
exit
endif
endif
enddo
RETURN .T.
*-- EoF: Delay()
*-------------------------------------------------------------------------------
*-- End of Program: OBSOLETE.PRG
*-------------------------------------------------------------------------------